home *** CD-ROM | disk | FTP | other *** search
/ L' Effet Pommier 3 / L'Effet Pommier - Volume 03.iso / Programmation / Alpha ƒ / Tcl / SystemCode / shell.tcl < prev    next >
Text File  |  1996-01-12  |  13KB  |  514 lines
  1.  
  2. ################################################################################
  3. # Shell routines.
  4. ################################################################################
  5.  
  6.  
  7. proc setShellMode {} {
  8.     setTclMode
  9.     changeMode "Shel"
  10.     insertMenu "Tcl"
  11. }
  12.  
  13. proc initShell {} {
  14.     insertText "Welcome to Alpha's Tcl shell."
  15.     insertText -w [lindex [winNames] 0] [shellPrompt]
  16. }
  17.  
  18. # Return the prompt. We want the window name because some of the commands
  19. # we evaluate (such as 'edit') open a new window, and we want the insertion
  20. # to be done in the shell window.
  21. proc shellPrompt {} {
  22.     return "\r╟[file tail [string trimright [pwd] {:}]]╚ "
  23. }
  24.  
  25.  
  26. # Called at all carriage returns.
  27. proc carriageReturn {} {
  28.     global mode
  29.     global indentOnCR
  30.     set indentString ""
  31.     deleteText [getPos] [selEnd]
  32.     if {$indentOnCR} {
  33.         set pos [getPos]
  34.         set text [getText [lineStart $pos] $pos]
  35.         for {set i 0; set len [string length $text]} {$i <= $len} {incr i} {
  36.             set c [string index $text $i]
  37.             if {($c != "\t") && ($c != "\ ")} {
  38.                 set indentString [string range $text 0 [expr $i-1]]
  39.                 break
  40.             }
  41.         }
  42.     }
  43.     insertText "\r" $indentString
  44. }
  45.  
  46.  
  47. proc shellCarriageReturn {} {
  48.     global mode histnum
  49.     global _text
  50.     global _returnText
  51.     set pos [getPos]
  52.  
  53.     if {![catch {regexp {░} [getText $pos [nextLineStart $pos]]} res] && $res} {
  54.         gotoMatch; return;
  55.     }
  56.     set ind [string first "╚" [getText [lineStart $pos] $pos]]
  57.     if {$ind < 0} {
  58.         carriageReturn
  59.         return
  60.     }
  61.     set lStart [expr [lineStart $pos]+$ind+2]
  62.     endOfLine
  63.     set _text [getText $lStart [getPos]]
  64.     set fileName [lindex [winNames] 0]
  65.     if {[getPos] != [maxPos]} {
  66.         goto [maxPos]
  67.         insertText -w $fileName $_text
  68.     }
  69.     if {[string first "Toolserver" $fileName] != -1} {
  70.         if {![catch {dosc -n ToolServer -s $_text} _returnText]} {
  71.             insertText "\r" $_returnText
  72.         } else {
  73.             insertText "\r"
  74.         }
  75.         mpwPrompt
  76.     } else {
  77.         uplevel #0 {catch $_text _returnText}
  78.         history add $_text
  79.         if {[string length $_returnText]} {
  80.             insertText -w $fileName "\r" $_returnText [shellPrompt]
  81.         } else {
  82.             insertText -w $fileName [shellPrompt]
  83.         }
  84.         set histnum [history nextid]
  85.     }
  86.     unset _text
  87.     unset _returnText
  88. }
  89. bind '\r' carriageReturn
  90. bind '\r' shellCarriageReturn "Shel"
  91. bind '\r' shellCarriageReturn "MPW"
  92.  
  93.  
  94. bind up <z> prevHist Shel
  95. bind down <z> nextHist Shel
  96.  
  97. proc prevHist {} {
  98.     global histnum
  99.     
  100.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  101.     if {[set ind [string first "╚ " $text]] > 0} {
  102.         goto [expr [lineStart [getPos]] + $ind + 2]
  103.     } else return
  104.  
  105.     incr histnum -1
  106.     if {[catch {history event $histnum} text]} {
  107.         incr histnum
  108.         endOfLine
  109.         return
  110.     }
  111.     set to [nextLineStart [getPos]]
  112.     if {[lookAt [expr $to-1]] == "\r"} {incr to -1}
  113.     replaceText [getPos] $to $text
  114. }
  115.  
  116.  
  117. proc nextHist {} {
  118.     global histnum
  119.     
  120.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  121.     if {[set ind [string first "╚ " $text]] > 0} {
  122.         goto [expr [lineStart [getPos]] + $ind + 2]
  123.     } else return
  124.  
  125.     incr histnum
  126.     if {[catch {history event $histnum} text]} {
  127.         incr histnum -1
  128.         endOfLine
  129.         return
  130.     }
  131.     set to [nextLineStart [getPos]]
  132.     if {[lookAt [expr $to-1]] == "\r"} {incr to -1}
  133.     replaceText [getPos] $to $text
  134. }
  135.  
  136.     
  137. proc startMPW {} {
  138.     global toolserverPath
  139.  
  140.     if {![string length [checkRunning ToolServer MPSX toolserverPath]]} return
  141.  
  142.     insertText "Welcome to Alpha's MPW shell (using ToolServer via AppleEvents)."
  143.     bind '\r' shellCarriageReturn "MPW"
  144.     carriageReturn
  145.     mpwPrompt
  146. }
  147. proc mpwPrompt {} {
  148.     insertText "╟mpw╚ "
  149. }
  150.  
  151. proc setMPWMode {} {
  152.     changeMode "MPW"
  153. }
  154.  
  155. #    shellCarriageReturn
  156.  
  157.  
  158.  
  159. #=============================================================================
  160. #    Shell Aliases
  161. #=============================================================================
  162.  
  163.  
  164. proc l {args} {
  165.     eval [concat "ls -CF" $args]}
  166.  
  167. proc ll {args} {
  168.     eval [concat "ls -l" $args]}
  169.  
  170.  
  171. proc wc {args} {
  172.     set res {}
  173.     set totChars 0
  174.     set totLines 0
  175.     set totWords 0
  176.     set args [glob -nocomplain $args]
  177.     foreach file $args {
  178.         set id [open $file]
  179.         set chars [string length [set text [read $id]]]
  180.         set lines [llength [split $text "\n"]]
  181.         set words [llength [split $text]]
  182.         append res [format "\r%8d%8d%8d    $file" $lines $words $chars]
  183.         set totChars [expr $totChars+$chars]
  184.         set totWords [expr $totWords+$words]
  185.         set totLines [expr $totLines+$lines]
  186.         close $id
  187.     }
  188.     if {[llength $args] > 1} {
  189.         append res [format "\r%8d%8d%8d    total" $totLines $totWords $totChars]
  190.     }
  191.     return [string range $res 1 end]
  192. }
  193.  
  194. ###########################################################################
  195. #  better-cp-mv.tcl  -- modification of your routines, by Mark Nagata
  196. #  for Alpha 5.72,  1/04/94
  197. ###########################################################################
  198. proc cp args {
  199.     if {[set len [llength $args]] < 2} {
  200.         error "usage: cp <file1> <file2>\r       cp <file1> .... <dir>"
  201.     }
  202.     set len [expr $len-1]
  203.     set dir [lindex $args $len]
  204.     if {![regexp {:} $dir] && $dir != ""} {
  205.         set dir ":$dir"
  206.     }
  207.     if {[regexp {:$} $dir]} {
  208.         set dir [string trimright $dir {:}]
  209.     }
  210.     set args [lreplace $args $len $len]
  211.     set files {}
  212.     foreach arg $args {
  213.         append files " " [glob $arg]
  214.     }
  215.     set report ""
  216.     if {[llength $files] == 1} {
  217.         set f [lindex $files 0]
  218.         if {[file exists $dir]} {
  219.             set targ $dir:[file tail $f]
  220.             append report $f\ ->\ $targ \r 
  221.             copyFile $f $targ
  222.         } else {
  223.             append report $f\ ->\ $dir \r
  224.             copyFile $f $dir
  225.         }
  226.     } else {
  227.         foreach f $files {
  228.             message [file tail $f]
  229.             set targ $dir:[file tail $f]
  230.             if {[catch {copyFile $f $targ} that]} {
  231.                 append report "Error copying '$f': $that\r"
  232.             } else {
  233.                 append report $f\ ->\ $targ \r
  234.             }
  235.         }
  236.     }
  237.     echo [string trimright $report]
  238. }
  239.  
  240. proc mv args {
  241.     if {[set len [llength $args]] < 2} {
  242.         error "usage: mv <file1> <file2>\r       mv <file1> .... <dir>"
  243.     }
  244.     set len [expr $len-1]
  245.     if {![regexp {.*[^:]} [lindex $args $len] dir]} {
  246.         set dir [string range [lindex $args $len] 1 end]
  247.     }
  248.     if {![regexp {:} $dir] && $dir != ""} {
  249.         set dir [concat :$dir]}
  250.     set args [lreplace $args $len $len]
  251.     set files {}
  252.     foreach arg $args {
  253.         append files " " [glob $arg]
  254.     }
  255.     set report ""
  256.     if {[llength $files] == 1} {
  257.         set f [lindex $files 0]
  258.         if {[file exists $dir]} {
  259.             set targ $dir:[file tail $f]
  260.             append report $f\ >->\ $targ \r
  261.             moveFile $f $targ
  262.         } else {
  263.             append report $f\ >->\ $dir \r
  264.             moveFile $f $dir
  265.         }
  266.     } else {
  267.         foreach f $files {
  268.             message [file tail $f]
  269.             set targ $dir:[file tail $f]
  270.             if {[catch {moveFile $f $targ} that]} {
  271.                 append report "Error moving '$f': $that\r"
  272.             } else {
  273.                 append report $f\ >->\ $targ \r
  274.             }
  275.         }
  276.     }
  277.     echo [string trimright $report]
  278. }
  279.  
  280.  
  281. proc rm args {
  282.     set files {}
  283.     foreach arg $args {
  284.         append files " " [glob $arg]
  285.     }
  286.     foreach f $files {
  287.         message [file tail $f]
  288.         removeFile $f
  289.     }
  290. }
  291.  
  292.  
  293.  
  294.  
  295. #================================================================================
  296.  
  297.  
  298. proc tclFileCompletion {} {
  299.     set silly "*"
  300.     set pos [getPos]
  301.     set res [search -f 0 -i 0 -m 0 -r 1 -n {["\{ \t\r]} [expr $pos - 1]]
  302.     if {[string length $res]} {
  303.         set from [lindex $res 1]
  304.         if {$from < $pos} {
  305.             set pd [pwd]
  306.             set text [getText $from $pos]
  307.             if {[string index $text 0] == ":"} {
  308.                 set pd [string trimright $pd ":"]
  309.             }
  310.             if {[catch {glob $pd$text$silly} globbed]} {
  311.                 set globbed [glob $text$silly]
  312.                 set pd ""
  313.             }
  314.             if {[llength $globbed] == 1} {
  315.                 set len [string length $pd$text]
  316.                 insertText [string range [lindex $globbed 0] $len end]
  317.             } elseif {[llength $globbed] != 0} {
  318.                 set globbed [lsort $globbed]
  319.                 set one [lindex $globbed 0]
  320.                 set two [lindex $globbed end]
  321.                 
  322.                 set len [string length $pd$text]
  323.                 set one [string range $one $len end]
  324.                 set two [string range $two $len end]
  325.                 
  326.                 set elen [string length $one]
  327.                 if {[string length $two] < $elen} {
  328.                     set elen [string length $two]
  329.                 }
  330.                 set len 0
  331.                 set str ""
  332.                 while {($len < $elen) && ([string match $str[string index $one $len]$silly $two])} {
  333.                     append str [string index $one $len]
  334.                     incr len
  335.                 }
  336.  
  337.                 if {!$len} {
  338.                     set elen [string length $pd]
  339.                     foreach g $globbed {
  340.                         lappend short [string range $g $elen end]
  341.                     }
  342.                     set blah [getText [lineStart [getPos]] [getPos]]
  343.                     insertText "\r" $short "\r" $blah
  344.                 } else {
  345.                     insertText $str
  346.                 }
  347.             }
  348.         }
  349.     }
  350. }
  351.  
  352.  
  353.  
  354. #================================================================================
  355. # To prevent ambiguity, 'from' is assumed to be a complete pathname, ending
  356. # in a directory name. If it doesn't end w/ a colon, one is added. 'to' is
  357. # assumed to be the parent directory of the top directory we are creating.
  358. #================================================================================
  359. proc cpdir {from to} {
  360.     set cwd [pwd]
  361.     if {[string match ":*" $from] || [string match ":*" $to] ||
  362.         ![file exists $from] || ![file exists $to]} {
  363.         error "'cpdir' args must be complete pathnames of existing folders."
  364.     }
  365.     if {![string match "*:" $from]} {append from ":"}
  366.     if {![string match "*:" $to]} {append to ":"}
  367.     
  368.     if {![file isdir $from] || ![file isdir $to]} {
  369.         exit 1
  370.     }
  371.         
  372.     set res [catch {cphier $from $to} val]
  373.     cd $cwd
  374.     if {$res} {error $val}
  375. }
  376.  
  377. proc cphier {from to} {
  378.     set savedir [pwd]
  379.     if {[string index $from [expr [string len $from] - 1]] != ":"} {append from ":"}
  380.     set dir [file tail [string trimright $from ":"]]
  381.     cd $to
  382.     mkdir "$dir"
  383.     foreach f [glob "$from*"] {
  384.         if {[file isdir $f]} {
  385.             cphier "$f:" "$to$dir:"
  386.         } else {
  387.             cp $f $to$dir:
  388.         }
  389.     }
  390.     cd $savedir
  391. }
  392.  
  393.  
  394. proc shellBol {} {
  395.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  396.     if {[set ind [string first "╚ " $text]] > 0} {
  397.         goto [expr [lineStart [getPos]] + $ind + 2]
  398.     } else {
  399.         goto [lineStart [getPos]]
  400.     }
  401. }
  402. bind 'a' <z> shellBol Shel
  403.  
  404.  
  405. proc dummyShel {} {dummyTcl}
  406.  
  407. #================================================================================
  408.  
  409. proc shellup {} {
  410.     set pos [expr [lineStart [getPos]] - 1]
  411.     if {[catch {regexp {░} [getText [lineStart $pos] [nextLineStart $pos]]} res] || !$res} {
  412.         previousLine; return
  413.     }
  414.     select [lineStart $pos] [nextLineStart $pos]
  415. }
  416. bind up shellup Shel
  417.  
  418.  
  419. proc shelldown {} {
  420.     set pos [nextLineStart [getPos]]
  421.     if {[catch {regexp {░} [getText $pos [nextLineStart $pos]]} res] || !$res} {
  422.         nextLine; return
  423.     }
  424.     select $pos [nextLineStart $pos]
  425. }
  426. bind down shelldown Shel
  427.  
  428.         
  429. #================================================================================
  430. proc sortdt {dt} {
  431.     scan $dt "%d/%d/%d {%d:%d:%d %1sM}" mon day yea hou min sec z
  432.     if {$z == "P"} {incr hou 12}
  433.     return [format "%02d%02d%02d%02d%02d" $yea $mon $day $hou $min]
  434. }
  435.  
  436.  
  437. proc lt args {
  438.     set val "*"
  439.     set sort 1
  440.     scan [lindex [mtime [now]] 0] "%d/%d/%d" one two three
  441.     set year 19$three
  442.     
  443.     foreach arg $args {
  444.         switch -- $arg {
  445.             "-t"     {set sort 0}
  446.             default    {set val $arg}
  447.         }
  448.     }
  449.     set mod ""
  450.     foreach f [eval glob $val] {
  451.         if {[catch {getFileInfo $f info}]} {
  452.             if {$sort} {set mod "0000000000 "}
  453.             lappend text [format "%s%s %8d%8d %6s %5s %4s %s %s\n" $mod "D" "0" "0" "" "" "" "DIR " [file tail $f]]
  454.             continue
  455.         }
  456.         if {$sort} {set mod "[sortdt [mtime $info(modified) s]] "}
  457.         set m [mtime $info(modified) a]
  458.         set zer [lindex $m 0]
  459.         set dat [format "%s %2s" [lindex $zer 1] [string trimright [lindex $zer 2] {,}]]
  460.         if {[lindex $zer 3] == $year} {
  461.             if {[scan [lindex $m 1] "%d:%d:%d %s" one two three am] != 4} {
  462.                 error "Didn't get four from scan"
  463.             }
  464.             if {[string length $two] == 1} {set two "0$two"}
  465.             set tm [expr {$am == "AM"} ? $one : [expr $one + 12]]:$two
  466.         } else {
  467.             set tm " [lindex $zer 3]"
  468.         }
  469.         lappend text [format "%sF %8d%8d %s %5s %s %s %s\n" $mod $info(datalen) $info(resourcelen) $dat $tm $info(creator) $info(type) [file tail $f]]
  470.     }
  471.     if {$sort} {
  472.         foreach ln [lsort -de $text] {
  473.             append txt [string range $ln 11 end]
  474.         }
  475.         return [string trimright $txt]
  476.     } else {
  477.         return [string trimright [join $text {}]]
  478.     }
  479. }
  480.  
  481. #================================================================================
  482. proc ps {} {
  483.     foreach p [processes] {
  484.         append text [format "%-25s %4s %10d %10d\r" [lindex $p 0] [lindex $p 1] [lindex $p 2] [lindex $p 3]]
  485.     }
  486.     return [string trimright $text]
  487. }
  488.  
  489.  
  490. #================================================================================
  491. # Recursively make creator of all text files 'ALFA'. Optionally takes a starting
  492. # dir argument, otherwise starts in current directory. Auto-Doubled are no 
  493. # longer recognized by auto-doubler! Why? Some sort of conflict w/ 'PBSetFInfo'.
  494. proc creator {{dir ":"}}  {
  495.     if {![catch {glob -t TEXT $dir*} files]} {
  496.         foreach f $files {
  497.             message $f
  498.             setFileInfo $f creator ALFA
  499.         }
  500.     }
  501.  
  502.     if {![catch {glob $dir*} dirs]} {
  503.         foreach d $dirs {
  504.             if {[file isdir $d]} {creator $d:}
  505.         }
  506.     }
  507. }
  508.  
  509.  
  510.  
  511. #===============================================================================
  512.  
  513. proc ShelDblClick {from to} { TclDblClick $from $to }
  514.